home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / gfaxpert.lzh / GFAXPERT.LIB / GRAPH2.LST < prev    next >
Encoding:
File List  |  1986-10-19  |  6.7 KB  |  268 lines
  1. ' ******************
  2. ' *** GRAPH2.LST ***
  3. ' ******************
  4. '
  5. DEFWRD "a-z"
  6. '
  7. > PROCEDURE clip.rectangle(VAR rectangle$,x,y)
  8.   ' *** cut rectangle (GET-string) from screen
  9.   ' *** returns left upper corner (x,y) as well
  10.   ' *** uses Procedure Click.point, Message.on and Message.off
  11.   LOCAL clp.x2,clp.y2,x1,y1,mx,my,x2,y2,k
  12.   @click.point("click on left upper corner of rectangle",x,y)
  13.   @message.on("choose rectangle (confirm with click)")
  14.   x1=MOUSEX
  15.   y1=MOUSEY
  16.   REPEAT
  17.     MOUSE mx,my,k
  18.   UNTIL mx<>x1 OR my<>y1
  19.   @message.off
  20.   GRAPHMODE 3
  21.   MOUSE x2,y2,k
  22.   REPEAT
  23.     BOX x,y,x2,y2
  24.     PLOT x,y
  25.     REPEAT
  26.       MOUSE clp.x2,clp.y2,k
  27.     UNTIL (clp.x2<>x2 AND clp.x2>x) OR (clp.y2<>y2 AND clp.y2>y) OR k>0
  28.     BOX x,y,x2,y2
  29.     PLOT x,y
  30.     x2=clp.x2
  31.     y2=clp.y2
  32.   UNTIL k>0
  33.   GRAPHMODE 1
  34.   GET x,y,clp.x2,clp.y2,rectangle$
  35.   PAUSE 10                  ! short pause for release of button
  36. RETURN
  37. ' **********
  38. '
  39. > PROCEDURE drag.clip
  40.   ' *** drag GET-rectangle on screen
  41.   ' *** original rectangle is not erased
  42.   ' *** uses Procedure Clip.rectangle, Click.point, Message.on and Message.off
  43.   LOCAL dx1,dy1,k,dx2,dy2,clip$
  44.   @clip.rectangle(clip$,dx1,dy1)
  45.   @message.on("move rectangle (place with click)")
  46.   SETMOUSE dx1,dy1
  47.   REPEAT
  48.     MOUSE dx,dy,k
  49.   UNTIL dx<>dx1 OR dy<>dy1
  50.   @message.off
  51.   HIDEM
  52.   MOUSE dx1,dy1,k
  53.   REPEAT
  54.     PUT dx1,dy1,clip$,6
  55.     REPEAT
  56.       MOUSE dx2,dy2,k
  57.     UNTIL dx2<>dx1 OR dy2<>dy1 OR k>0
  58.     PUT dx1,dy1,clip$,6
  59.     dx1=dx2
  60.     dy1=dy2
  61.   UNTIL k>0
  62.   PUT dx1,dy1,clip$,3
  63.   PAUSE 10
  64. RETURN
  65. ' **********
  66. '
  67. > PROCEDURE load.clip(clip.file$,VAR clip$)
  68.   ' *** load GET-rectangle from file and PUT on screen
  69.   ' *** GET-rectangle saved with : BSAVE file$,V:pic$,LEN(pic$)
  70.   ' *** use extension .PUT for these files
  71.   ' *** uses Standard Global Variables
  72.   LOCAL bytes,bit.planes,m$,k
  73.   IF EXIST(clip.file$)
  74.     OPEN "I",#90,clip.file$
  75.     bytes=LOF(#90)
  76.     CLOSE #90
  77.     clip$=SPACE$(bytes)
  78.     BLOAD clip.file$,VARPTR(clip$)
  79.     bit.planes=DPEEK(VARPTR(clip$)+4)
  80.     SELECT bit.planes
  81.     CASE 1
  82.       IF NOT high.res!
  83.         m$="PUT-picture|suitable for|High resolution|only ???"
  84.         ALERT 3,m$,1,"EDIT",k
  85.         EDIT
  86.       ENDIF
  87.     CASE 2
  88.       IF NOT med.res!
  89.         m$="PUT-picture|suitable for|Medium resolution|only ???"
  90.         ALERT 3,m$,1,"EDIT",k
  91.         EDIT
  92.       ENDIF
  93.     CASE 4
  94.       IF NOT low.res!
  95.         m$="PUT-picture|suitable for|Low resolution|only ???"
  96.         ALERT 3,m$,1,"EDIT",k
  97.         EDIT
  98.       ENDIF
  99.     ENDSELECT
  100.   ELSE
  101.     m$=clip.file$+"| |not found !?"
  102.     ALERT 3,m$,1,"EDIT",k
  103.     EDIT
  104.   ENDIF
  105. RETURN
  106. ' **********
  107. '
  108. > PROCEDURE initio.picture
  109.   ' *** draw picture on invisible logical screen and save in GET-string
  110.   ' *** you probably should draw in a BOX
  111.   ' *** the origin (left upper corner) is the point 0,0
  112.   ' *** the following commands (with parameters) are allowed in DATA-lines :
  113.   ' ***         DEFLINE , DEFTEXT , LINE , DRAW , BOX , RBOX , TEXT , END
  114.   ' *** DRAW-format : DATA DRAW,number_of_points,x1,y1,x2,y2,x3,y3,etc.
  115.   ' *** last DATA-line : END
  116.   ' *** normal picture on screen : PUT x,y,picture$,3
  117.   ' *** reverse picture on screen : PUT x,y,picture$,12 (don't use RBOX))
  118.   '
  119.   ' *** uses Procedure Initio.logical.screen etc.
  120.   '
  121.   @initio.logical.screen
  122.   '
  123.   ' *** here is an example of the different commands
  124.   test.picture:
  125.   DATA BOX,0,0,100,50
  126.   DATA DEFTEXT,1,0,900,8
  127.   DATA TEXT,9,45,test
  128.   DATA DEFTEXT,1,0,2700,8
  129.   DATA TEXT,90,5,test
  130.   DATA LINE,0,0,100,50
  131.   DATA DRAW,4,50,10,75,45,25,45,50,10
  132.   DATA END
  133.   RESTORE test.picture
  134.   @initio.draw.picture(test.picture$)
  135.   '
  136.   @restore.physical.screen
  137. RETURN
  138. ' ***
  139. > PROCEDURE initio.draw.picture(VAR pic$)
  140.   ' *** draw on invisible logical screen and put in GET-string
  141.   LOCAL command$,s,w,b,e,c,s,angle,h,x1,y1,x2,y2
  142.   LOCAL points,n,x,y,txt$,max.width,max.height
  143.   CLS
  144.   REPEAT
  145.     READ command$
  146.     command$=UPPER$(command$)
  147.     IF command$="DEFLINE"
  148.       READ s,w,b,e
  149.       DEFLINE s,w,b,e
  150.     ENDIF
  151.     IF command$="DEFTEXT"
  152.       READ c,s,angle,h
  153.       DEFTEXT c,s,angle,h
  154.     ENDIF
  155.     IF command$="LINE"
  156.       READ x1,y1,x2,y2
  157.       LINE x1,y1,x2,y2
  158.       @max.width.height
  159.     ENDIF
  160.     IF command$="DRAW"
  161.       READ points,x1,y1
  162.       PLOT x1,y1
  163.       @max.width.height
  164.       FOR n=1 TO points-1
  165.         READ x2,y2
  166.         DRAW  TO x2,y2
  167.         @max.width.height
  168.       NEXT n
  169.     ENDIF
  170.     IF command$="BOX"
  171.       READ x1,y1,x2,y2
  172.       BOX x1,y1,x2,y2
  173.       @max.width.height
  174.     ENDIF
  175.     IF command$="RBOX"
  176.       READ x1,y1,x2,y2
  177.       RBOX x1,y1,x2,y2
  178.       @max.width.height
  179.     ENDIF
  180.     IF command$="TEXT"
  181.       ' *** correct size of text is not tested !
  182.       READ x,y,txt$
  183.       TEXT x,y,txt$
  184.       IF angle=0
  185.         x2=x+LEN(txt$)*h/2
  186.         y2=y
  187.       ENDIF
  188.       IF angle=900
  189.         x2=x
  190.         y2=y
  191.       ENDIF
  192.       IF angle=2700
  193.         x2=x+h
  194.         y2=y+LEN(txt$)*h/2
  195.       ENDIF
  196.       @max.width.height
  197.     ENDIF
  198.   UNTIL command$="END"
  199.   GET 0,0,width.max,height.max,pic$
  200. RETURN
  201. ' ***
  202. > PROCEDURE max.width.height
  203.   width.max=MAX(width.max,x1)
  204.   height.max=MAX(height.max,y1)
  205.   width.max=MAX(width.max,x2)
  206.   height.max=MAX(height.max,y2)
  207. RETURN
  208. ' **********
  209. '
  210. > PROCEDURE cube(x,y,w,color,fill)
  211.   ' *** draw cube (left upper corner x,y; fill=fillpattern)
  212.   ' *** color of edges and pattern is the same
  213.   LOCAL d,e
  214.   d=w/3
  215.   e=w+d
  216.   ERASE cube.x(),cube.y()
  217.   DIM cube.x(6),cube.y(6)
  218.   cube.x(0)=x
  219.   cube.x(1)=x
  220.   cube.x(2)=x+d
  221.   cube.x(3)=x+e
  222.   cube.x(4)=x+e
  223.   cube.x(5)=x+w
  224.   cube.x(6)=x
  225.   cube.y(0)=y
  226.   cube.y(1)=y+w
  227.   cube.y(2)=y+e
  228.   cube.y(3)=y+e
  229.   cube.y(4)=y+d
  230.   cube.y(5)=y
  231.   cube.y(6)=y
  232.   DEFFILL color,2,fill
  233.   POLYFILL 7,cube.x(),cube.y()
  234.   COLOR color
  235.   DRAW x,y+w TO x+w,y+w TO x+w,y
  236.   DRAW x+w,y+w TO x+e,y+e
  237. RETURN
  238. ' **********
  239. '
  240. > PROCEDURE mirror(get.pic$,mode,VAR mir.pic$)
  241.   ' *** make mirror-image of GET-string
  242.   ' *** mode : 0=vertical 1=horizontal
  243.   LOCAL adr%,pic1%,pic2%,w,h,words,bit_rest
  244.   '
  245.   ' *** load MIRROR.INL (238 bytes) here
  246.   INLINE mirror%,238
  247.   '
  248.   IF DIM?(mir%())=0
  249.     DIM mir%(16)
  250.   ENDIF
  251.   mir.pic$=get.pic$
  252.   pic2%=ADD(V:mir.pic$,6)
  253.   adr%=V:get.pic$
  254.   pic1%=ADD(adr%,6)
  255.   w=SUCC(WORD{adr%})                    ! width (pixels)
  256.   words=INT(ADD(w,15)/16)               ! width (words)
  257.   bit_rest=SUB(MUL(words,16),w)         ! ignore these bits of last word of line
  258.   mir%(0)=words
  259.   mir%(1)=SUCC(WORD{ADD(adr%,2)})       ! height
  260.   mir%(2)=bit_rest
  261.   mir%(3)=mode
  262.   mir%(8)=pic1%                         ! source
  263.   mir%(9)=pic2%                         ! destination
  264.   RCALL mirror%,mir%()
  265. RETURN
  266. ' **********
  267. '
  268.